COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(DEFUN INST (PAT EXP W)  Included to play with and show similarity to unify
C00011 ENDMK
C⊗;
(DEFUN INST (PAT EXP W) ; Included to play with and show similarity to unify
       (COND ((EQ W 'NO) 'NO)
	     ((ATOM PAT)
	      (COND ((MEMQ PAT VARS)
		     ((LAMBDA (Z) (COND ((NULL Z)
					 (CONS (CONS PAT EXP) W)
					 ((EQUAL (CDR Z) EXP) W)
					 (T 'NO)))
				  (ASSOC PAT W))))
		    ((EQ PAT EXP) W)
		    (T 'NO))
	      ((ATOM EXP) 'NO)
	      (T (INST (CDR PAT)
		       (CDR EXP)
		       (INST (CAR PAT) (CAR EXP) W)))))) 

(DEFUN FREES (E) (REMOVDUPS (FREE1 E NIL))) ; borrowed from midterm answers

(DEFUN FREE1 (E BOUND) 						       ; Looks for any variable not in Bound
       (COND ((OR (NULL E) (EQ E T) (NUMBERP E)) NIL)		       ; Ignores constants
	     ((ATOM E) (COND ((MEMBER E BOUND) NIL) (T (LIST E))))     ; collects unbound vars
	     ((OR (EQ 'GO (CAR E)) (EQ 'QUOTE (CAR E)))
	      NIL)						       ; Ignores labels in GO statements
	     ((EQ 'LAMBDA (CAR E))				       ; Collects bound vars whenever possible
	      (FREE1 (CDDR E) (APPEND (CADR E) BOUND)))
	     ((EQ 'DEFUN (CAR E))
	      (FREE1 (CDDDR E) (APPEND (CADDR E) BOUND)))
	     ((EQ 'PROG (CAR E))				       ;Calls stripatoms to avoid labels in the
	      (FREE1 (STRIPATOMS (CDDR E)) (APPEND (CADR E) BOUND)))   ;PROG
	     ((ATOM (CAR E))					       ; Takes all the arguments of function
	      (MAPCARAPP (FUNCTION FREE1) (CDR E) BOUND))	       ;but not fun name
	     (T (MAPCARAPP (FUNCTION FREE1) E BOUND)))) 	       ;Takes all elements of the list  This is
								       ;Map Car Append, like system function
								       ;MAPCAN, but with extra arguments
								       ;allowed

(DEFUN MAPCARAPP (FUN LISTARG ARG2) 
       (COND ((NULL LISTARG) NIL)
	     (T (APPEND (APPLY FUN (LIST (CAR LISTARG) ARG2))
			(MAPCARAPP FUN (CDR LISTARG) ARG2))))) 

(DEFUN REMOVDUPS (U) 						       ; Gets rid of any element that occurs
       (COND ((NULL U) NIL)					       ;later in list
	     ((MEMBER (CAR U) (CDR U)) (REMOVDUPS (CDR U)))
	     (T (CONS (CAR U) (REMOVDUPS (CDR U)))))) 		       ; Returns all of list except atoms at
								       ;top level (labels in this case)

(DEFUN STRIPATOMS (U) 
       (COND ((NULL U) NIL)
	     ((ATOM (CAR U)) (CDR U))
	     (T (CONS (CAR U) (STRIPATOMS (CDR U)))))) 

(DEFUN FRUITLOOP (X) ; Makes a prog with looping for tail recursive defuns
       (PROG (NAME CONDI ARGS) 
	     (RETURN
	      (COND ((AND (EQ (CAR X) 'DEFUN)
			  (EQ (CAR (SETQ CONDI (CADDDR X)))
			      'COND)
			  (BARECALL (SETQ NAME (CADR X)) (CDR CONDI)))
		     (LIST 'DEFUN
			   NAME
			   (SETQ ARGS (CADDR X))
			   (LIST 'PROG
				 NIL
				 NAME
				 (LIST 'RETURN
				       (CONS 'COND
					     (MAKCOND (CDR CONDI)
						      NAME
						      ARGS))))))
		    (T X))))) 

(DEFUN BARECALL (NAME CLIST) ; Spots simple tail recursion
       (COND ((NULL CLIST) NIL)
	     ((EQ NAME (CAADAR CLIST)) CLIST)
	     (T (BARECALL NAME (CDR CLIST))))) 

(DEFUN MAKCOND (CONDI NAME ARGS) ; Remakes a conditional, substituting the extra code
       (COND ((NULL CONDI) NIL)
	     ((BARECALL NAME (LIST (CAR CONDI)))
	      (CONS (FIXUPCOND (CAR CONDI) ARGS)
		    (MAKCOND (CDR CONDI) NAME ARGS)))
	     (T (CONS (CAR CONDI) (MAKCOND (CDR CONDI) NAME ARGS))))) 

(DEFUN FIXUPCOND (CPAIRS ARGS) ; Fixes a single test-result pair of a conditional
       (APPEND (LIST (CAR CPAIRS))
	       (RESETARGS ARGS (CDADR CPAIRS))
	       (LIST (LIST 'GO NAME)))) 

(DEFUN MAKSETQS (VARS VALS) ; makes a series of setqs for the args and values
       (COND ((NULL VARS) NIL)
	     (T (CONS (LIST 'SETQ (CAR VARS) (CAR VALS))
		      (MAKSETQS (CDR VARS) (CDR VALS)))))) 

(DEFUN RESETARGS (ARGS VALS) ; Reassigns the args to new value, using lambda if needed
       (COND ((NEEDLAMBDA ARGS VALS NIL) (MAKLAMBDA ARGS VALS))
	     (T (MAKSETQS ARGS VALS)))) 

(DEFUN NEEDLAMBDA (ARGS VALS CHANGED) ; Tests whether an args gets used after being reset
       (COND ((NULL ARGS) NIL)
	     ((INTERSECTION CHANGED (FREES (CAR VALS))) T)
	     (T (NEEDLAMBDA (CDR ARGS)
			    (CDR VALS)
			    (CONS (CAR ARGS) CHANGED))))) 
(DEFUN MAKLAMBDA (ARGS VALS) ; Makes a lambda to allow simultaneous resetting of args
       ((LAMBDA (GVARS) (LIST (LIST 'LAMBDA
				    GVARS
				    (MAKSETQS ARGS GVARS))
			      VALS))
	(DONTIMES (FUNCTION GENSYM) (LENGTH ARGS)))) 

(DEFUN INTERSECTION (A B) ; does simple set intersection
       (COND ((NULL A) NIL)
	     ((MEMQ (CAR A) B)
	      (CONS (CAR A) (INTERSECTION (CDR A) B)))
	     (T (INTERSECTION (CDR A) B)))) 

(DEFUN DONTIMES (FUN N) ; returns list of fun done n times
       (COND ((EQ 0. N) NIL)
	     (T (CONS (FUN) (DONTIMES FUN (- N 1.)))))) 

(DEFUN UNIFY (X1 X2) (UNIF X1 X2 '(U V W X Y Z) NIL)) ; Unifies with assumed variable convention

(DEFUN UNIF (X1 X2 VARS W) ; does the work the same way as inst
       (COND ((EQ W 'NO) 'NO)
	     ((EQUAL X1 X2) W)
	     ((OR (ATOM X1) (ATOM X2))
	      (COND ((MEMQ X1 VARS) (MASH X1 X2))
		    ((MEMQ X2 VARS) (MASH X2 X1))
		    (T 'NO)))
	     (T (UNIF (CDR X1)
		      (CDR X2)
		      VARS
		      (UNIF (CAR X1) (CAR X2) VARS W))))) 

(DEFUN MASH (ATM EXP) ; Core of inst, lifted to avoid writing twice
       ((LAMBDA (Z) (COND ((NULL Z) (CONS (CONS ATM EXP) W))
			  ((EQUAL (CDR Z) EXP) W)
			  (T 'NO)))
	(ASSOC ATM W)))